home *** CD-ROM | disk | FTP | other *** search
/ Delphi 2 - Developers' Solutions / Delphi 2 Developers' Solutions.iso / dds / comps / widgets / delphi10 / icnflbox / icnflbox.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-06-15  |  6.1 KB  |  182 lines
  1. unit Icnflbox;
  2.  
  3. interface
  4.  
  5. uses
  6.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  7.   Forms, Dialogs, StdCtrls;
  8.  
  9. type
  10.   TIconsAndFilesListbox = class(TFileListbox)
  11.   public
  12.     { public methods and data }
  13.     procedure ReadFileNames; override;
  14.   end;
  15.  
  16. procedure Register;
  17.  
  18. implementation
  19.  
  20. { Modified from VCL Source Copyright 1995 }
  21. { Borland International, Inc.             }
  22. { Use this to override display with icons }
  23. procedure TIconsAndFilesListBox.ReadFileNames;
  24. { This procedure gets an icon for a file using FindExecutable  }
  25. { and ExtractIcon. (assumes file/dir is passed)                }
  26. procedure GetIconForFile( TheName : String; var TheIcon : TIcon );
  27. var TheExt           : String; { File extension holder }
  28.     TheOtherPChar  ,           { Windows ASCIIZ string }
  29.     ThePChar         : PChar;  { Windows ASCIIZ string }
  30.     Dummy : Word;
  31. begin
  32.   { Check for directory and if so get directory icon from RES file }
  33.   if (( FileGetAttr( TheName ) and faDirectory ) = faDirectory ) then
  34.   begin
  35.     { Set up the PChar to communicate with Windows }
  36.     GetMem( TheOtherPChar , 255 );
  37.     { Convert Pascal-style string to ASCIIZ Pchar }
  38.     StrPCopy( TheOtherPChar , 'DIRECTORY' );
  39.     { Use API call to return icon handle of Icon Resource in FILECTRL.RES }
  40.     TheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  41.     { Release memory from PChar }
  42.     FreeMem( TheOtherPChar , 255 );
  43.     { Leave }
  44.     exit;
  45.   end;
  46.   { Assume archive file; get its extension }
  47.   TheExt := Uppercase( ExtractFileExt( TheName ));
  48.   { If not an executable/image file then use FindExecutable to get icon }
  49.   if (( TheExt <> '.EXE' ) and ( TheExt <> '.BAT' ) and
  50.       ( TheExt <> '.PIF' ) and ( TheExt <> '.COM' )) then
  51.   begin
  52.     { Grab three chunks of memory }
  53.     GetMem( ThePChar , 255 );
  54.     { Set up the name and its directory in Windows string formats }
  55.     StrPCopy( ThePChar, TheName );
  56.     Dummy := 65535;
  57.     {**** Windows 95 Specialized call ****** }
  58.     TheIcon.Handle := ExtractAssociatedIcon( hInstance , ThePChar , Dummy );
  59.     if TheIcon.Handle = 0 then
  60.     begin
  61.       GetMem( TheOtherPChar , 255 );
  62.       StrPCopy( TheOtherPChar , 'NOICON' );
  63.       TheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  64.       FreeMem( TheOtherPChar , 255 );
  65.       exit;
  66.     end;
  67.     FreeMem( ThePChar , 255 );
  68.   end
  69.   else
  70.   { Assume Windows Executable file, so get icon from it with ExtractIcon API }
  71.   begin
  72.     GetMem( ThePChar , 255 );
  73.     StrPCopy( ThePChar , TheName );
  74.     { Try to get first icon for file }
  75.     Dummy := 65535;
  76.     TheIcon.Handle := ExtractAssociatedIcon( hInstance , ThePChar , Dummy );
  77.     FreeMem( ThePChar , 255 );
  78.     { If handle is 0 invalid icon format so use default from RES file }
  79.     if TheIcon.Handle = 0 then
  80.     begin
  81.       GetMem( TheOtherPChar , 255 );
  82.       StrPCopy( TheOtherPChar , 'NOICON' );
  83.       TheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  84.       FreeMem( TheOtherPChar , 255 );
  85.       exit;
  86.     end;
  87.   end;
  88. end;
  89.  
  90. var
  91.   AttrIndex   : TFileAttr;
  92.   i           : Integer;
  93.   FileExt     : string;
  94.   MaskPtr     : PChar;
  95.   Ptr         : PChar;
  96.   AttrWord    : Word;
  97.   TempPicture : TPicture;
  98.   TempBmp     : TBitmap;
  99.   TempIcon    : TIcon;
  100. const
  101.   Attributes: array[TFileAttr] of Word =
  102.   ( DDL_READONLY , DDL_HIDDEN , DDL_SYSTEM , $0008 , DDL_DIRECTORY ,
  103.     DDL_ARCHIVE  , DDL_EXCLUSIVE );
  104. begin
  105.   { if no handle allocated yet, this call will force         }
  106.   { one to be allocated incorrectly (i.e. at the wrong time. }
  107.   { In due time, one will be allocated appropriately.        }
  108.   AttrWord := DDL_READWRITE;
  109.   if HandleAllocated then
  110.   begin
  111.     { Set attribute flags based on values in FileType }
  112.     for AttrIndex := ftReadOnly to ftArchive do
  113.      if AttrIndex in FileType then
  114.       AttrWord := AttrWord or Attributes[ AttrIndex ];
  115.  
  116.     { Use Exclusive bit to exclude normal files }
  117.     if not ( ftNormal in FileType ) then
  118.       AttrWord := AttrWord or DDL_EXCLUSIVE;
  119.  
  120.     ChDir( FDirectory ); { go to the directory we want }
  121.     Clear;               { clear the list }
  122.  
  123.     GetMem( MaskPtr , 256 );
  124.     StrPCopy( MaskPtr , FMask );
  125.     while MaskPtr <> nil do
  126.     begin
  127.       Ptr := StrScan ( MaskPtr , ';' );
  128.       if Ptr <> nil then  Ptr^ := #0;
  129.       { build the list }
  130.       SendMessage( Handle , LB_DIR , AttrWord , Longint( MaskPtr ));
  131.       if Ptr <> nil then
  132.       begin
  133.         Ptr^ := ';';
  134.         Inc ( Ptr );
  135.       end;
  136.       MaskPtr := Ptr;
  137.     end;
  138.     FreeMem( MaskPtr , 256 );
  139.     { Now add the bitmaps }
  140.     {---------------------------- begin custom code --------------------------}
  141.     { Create the TPicture for exchange purposes }
  142.     TempPicture := TPicture.Create;
  143.     { Set it to icon widths }
  144.     TempPicture.Bitmap.Width := 32;
  145.     TempPicture.Bitmap.Height := 32;
  146.     { Run down the list }
  147.     for i := 0 to Items.Count - 1 do
  148.     begin
  149.       { Create a New temporary icon }
  150.       TempIcon := TIcon.Create;
  151.       { Call the custom DRWS routine to get icon for a file }
  152.       GetIconForFile( Items[ i ] , TempIcon );
  153.       { Put the icon on the bitmap for the picture via draw }
  154.       { Note 1 , 1 due to bug in Draw?                      }
  155.       TempPicture.Bitmap.Canvas.Draw( 1 , 1 , TempIcon );
  156.       { Create a temporary bitmap }
  157.       TempBmp := TBitmap.Create;
  158.       { Set its width to those of the previous object's bitmaps }
  159.       TempBmp.Width := 16;
  160.       TempBmp.Height := 15;
  161.       { Resize the icon's bitmap to the smaller size with stretchdraw }
  162.       TempBmp.Canvas.StretchDraw( Rect( 1 , 1 , 15 , 14 ) ,
  163.        TempPicture.Bitmap );
  164.       { Set the Objects list to the bitmap }
  165.       Items.Objects[ i ] := TempBmp;
  166.       { Free the icon each iteration; don't free the TempBmp as list does }
  167.       TempIcon.Free;
  168.     end;
  169.     { Free the TPicture exchange element }
  170.     TempPicture.Free;
  171.     {------------------------ end custom code --------------------------------}
  172.     Change;
  173.   end;
  174. end;
  175.  
  176. procedure Register;
  177. begin
  178.   RegisterComponents('Widgets', [TIconsAndFilesListbox]);
  179. end;
  180.  
  181. end.
  182.